home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-03
/
qbpacket.zip
/
FRACTALS.BAS
< prev
next >
Wrap
BASIC Source File
|
1991-10-30
|
21KB
|
542 lines
REM QBASIC FRACTAL EXPLORER (FRACTALS.BAS)
'Subprogram declarations, generated automatically by QBasic
DECLARE SUB DrawTriFract ()
DECLARE SUB ShowFile ()
DECLARE SUB ShowStats ()
DECLARE SUB SaveCGA (FileName$)
DECLARE SUB SaveEGA (FileName$)
DECLARE SUB ShowCGA (FileName$)
DECLARE SUB ShowEGA (FileName$)
DECLARE SUB AnimateCGA ()
DECLARE SUB AnimateEGA ()
DECLARE SUB DrawFractal ()
DECLARE SUB SetupCGA ()
DECLARE SUB SetupEGA ()
DECLARE SUB SetupMDA ()
DECLARE SUB WaitKey ()
DECLARE SUB SetImage ()
DECLARE SUB SetSave ()
DECLARE SUB SetFractal ()
DECLARE SUB DoFractal ()
DECLARE SUB SetScreen ()
DECLARE SUB ShowMenu ()
DECLARE SUB TextScreen ()
'Constants to make loop tests more readable
CONST True = -1
CONST False = 0
ON ERROR GOTO HandleError: 'Set up error trapping
TYPE ScreenType 'Data type to hold screen information
Number AS INTEGER 'Number of screen to use with SCREEN statement
MaxColumns AS INTEGER 'Maximum columns (X coordinate)
MaxRows AS INTEGER 'Maximum rows (Y coordinate)
MaxColors AS INTEGER 'Maximum colors
Description AS STRING * 30 'Description of screen
Extension AS STRING * 3 'Filename extension for this screen type
END TYPE
MaxScreens% = 3 'Number of different screens supported
DIM Screens(1 TO MaxScreens%) AS ScreenType 'Holds ScreenType records
'Read in the information for each screen supported
FOR S = 1 TO MaxScreens%
READ Screens(S).Number
READ Screens(S).MaxColumns
READ Screens(S).MaxRows
READ Screens(S).MaxColors
READ Screens(S).Description
READ Screens(S).Extension
NEXT S
DATA 1,320,200,4, "CGA 320 x 200 4 colors","CGA"
DATA 2,640,200,2, "MDA 640 x 200 2 colors","MDA"
DATA 9,640,350,16,"EGA 640 x 350 16 colors","EGA"
'Default initialization
FractalType% = 1 'For Escape Time Fractals
Mode% = 1 'Screen mode; defaults to SCREEN 1, CGA
Save% = False 'Whether to save to disk after drawing
SetupCGA 'Set up default CGA parameters
DoMenu: 'Label for ON ERROR resume
ShowMenu 'This is the main program loop
END
'Error trapping routine
HandleError:
ErrNum = ERR 'Get error number from ERR function
SELECT CASE ErrNum 'Print appropriate message
CASE IS = 53
PRINT "File not found. Make sure you've typed"
PRINT "the name correctly."
WaitKey 'Let user read message and press a key
RESUME NEXT 'Loop back in calling routine
CASE IS = 64
PRINT "Bad file name. Filenames may not have"
PRINT "more than 8 characters and a 3-character"
PRINT "extension."
WaitKey
RESUME NEXT
CASE IS = 71
PRINT "Disk error. Make sure you have put a disk"
PRINT "in the drive and closed the drive door, if"
PRINT "necessary."
WaitKey
RESUME NEXT 'Loop back in calling routine
CASE ELSE 'Some other error has occurred
PRINT "Error number"; ErrNum; "has occurred"
WaitKey
RESUME DoMenu: 'Possibly serious error; so loop back to main
'menu
END SELECT
END
SUB AnimateCGA
WHILE INKEY$ = "" 'Run until user presses a key
COLOR , 0 'Switch CGA palette colors
FOR P = 1 TO 1000 'Pause a bit
NEXT P
COLOR , 1 'Switch back to first palette
FOR P = 1 TO 1000 'Pause again
NEXT P
WEND
END SUB
SUB AnimateEGA 'Animation (color cycling) for EGA
SHARED MaxColumns%, MaxRows%
DIM Palettearray%(15) 'Set up the initial colors of the EGA palette
FOR Temp% = 0 TO 15
Palettearray%(Temp%) = Temp%'This will "flash" the screen colors of
NEXT 'the fractal until the user presses a key
WHILE INKEY$ = ""
FOR Temp% = 0 TO 15 'Switch the EGA palette to successive colors
Palettearray%(Temp%) = Palettearray%(Temp%) + 1
IF Palettearray%(Temp%) > 63 THEN
Palettearray%(Temp%) = Palettearray%(Temp%) - 64
END IF
NEXT
PALETTE USING Palettearray%(0) 'Rotate the colors on the screen
WEND
END SUB
SUB DoFractal
SHARED Mode%, Save%, Time
CLS
SCREEN Mode% 'Make sure we have the right screen
T1 = TIMER 'Set up for timing
IF Save% THEN
PRINT "Enter filename to save"
INPUT "(no extension)"; FileName$
END IF
CLS
DrawFractal 'Generate the fractal image
T2 = TIMER 'Stop the timer
Time = T2 - T1 'Calculate elapsed time
SELECT CASE Mode%'Choose correct animation routine for screen mode being
'used
CASE IS = 1, IS = 2 'Add more CASEs if you add screen modes
AnimateCGA
CASE IS = 9
AnimateEGA
CASE ELSE
PRINT "Unsupported video mode in subprogram DoFractal"
END SELECT
IF Save% THEN 'Did user turn on save to disk feature?
SELECT CASE Mode% 'If so, choose correct disk save routine for
CASE IS = 1, IS = 2 'screen mode being used
SaveCGA (FileName$) 'Add more CASEs if you add screen
'modes
CASE IS = 9
SaveEGA (FileName$)
CASE ELSE
LOCATE 22, 1
PRINT "ERROR: Mode not defined for saving!"
END SELECT
END IF
END SUB
SUB DrawFractal 'For Escape Time fractals substitute different formulas as
'desired
SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%, FractalType%
FOR X1% = 1 TO MaxColumns% 'For each column
FOR Y1% = 1 TO MaxColumns% 'For each row
X = X1% / MaxColumns% 'Calculate initial comparison
Y = Y1% / MaxRows% 'For column and row
Count% = 0 'Start at count of 0
WHILE X * X + Y * Y <= Limit%'Until formulas pass cutoff point
'--------------------------------------------------------
'"Target" formulas for fractals. Instead of the
'following two lines, you can use other formulas. Put a
'REM or ' mark in front of other lines.
'--------------------------------------------------------
SELECT CASE FractalType%
CASE IS = 1
X = 2 * X '-----------------
Y = 2 * Y '"Target" formulas
CASE IS = 2 '-----------------
IF Y <= .5 THEN
IF X <= .5 THEN
X = 2 * X
Y = 2 * Y
ELSE X = 2 * X - 1
Y = 2 * Y
END IF
ELSE
X = 2 * X
Y = 2 * Y - 1
END IF
CASE ELSE
PRINT "Error in subprogram DrawFractal"
WaitKey
EXIT SUB
END SELECT
Count% = Count% + 1 'Keep track of number of passes
WEND 'When cutoff point reached, draw the point
PSET (X1%, Y1%), Count% \ ColorDivisor%
'SOUND 100 * Count%, 1 'Optional sound effects
'Use the appropriate color
NEXT 'Do the next row
NEXT 'Do the next column
END SUB
SUB SaveCGA (FileName$)
DEF SEG = &HB800 'Switch to CGA video memory
BSAVE FileName$, 0, 16383 'Save CGA image
DEF SEG 'Switch back to default segment
END SUB
SUB SaveEGA (FileName$)
'============================================================================
'Save EGA fractal image to disk--thanks to Ethan Winer of Crescent Software
'for this routine
'============================================================================
DEF SEG = &HA000 'Switch to EGA video memory
SIZE% = 28000 'Each plane is 28,000 bytes long
'Save blue plane
OUT &H3CE, 4
OUT &H3CF, 0
BSAVE FileName$ + ".BLU", 0, SIZE%
'Save green plane
OUT &H3CE, 4
OUT &H3CF, 1
BSAVE FileName$ + ".GRN", 0, SIZE%
'Save red plane
OUT &H3CE, 4
OUT &H3CF, 2
BSAVE FileName$ + ".RED", 0, SIZE%
'Save intensity plane
OUT &H3CE, 4
OUT &H3CF, 3
BSAVE FileName$ + ".INT", 0, SIZE%
OUT &H3CE, 4: OUT &H3CF, 0
DEF SEG 'Switch back to default segment
END SUB
SUB SetFractal
SHARED FractalType%
CLS
PRINT "Set the type of fractal."
PRINT
PRINT "1. Escape Time Fractal"
PRINT "2. Triangular Fractal"
ValidFractal% = False
WHILE NOT ValidFractal%
PRINT "Enter selection or press Escape to exit"
F$ = INPUT$(1)
IF F$ = CHR$(27) THEN EXIT SUB
FractalType% = VAL(F$)
IF FractalType% < 1 OR FractalType% > 2 THEN
PRINT "Error in subprogram SetFractal: Invalid fractal type"
ELSE
ValidFractal% = True
END IF
WEND
END SUB
SUB SetImage
SHARED MaxScreens%, Screens() AS ScreenType
SHARED Mode%, MaxColumns%, MaxRows%
FOR S = 1 TO MaxScreens%
IF Screens(S).Number = Mode% THEN 'Find out maximum rows and
ScrCols% = Screens(S).MaxColumns 'columns for current screen
ScrRows% = Screens(S).MaxRows 'mode
Found = True
EXIT FOR
END IF
NEXT S
IF NOT Found THEN
PRINT "ERROR: Invalid screen in SetImage program!"
EXIT SUB
END IF
CLS
PRINT "Set size of screen image."
PRINT "Number of columns (1 -"; ScrCols%; ")"
INPUT ImageCols%
IF ImageCols% < 1 OR ImageCols% > ScrCols% THEN 'Make sure number of
PRINT "Invalid number of columns" 'columns doesn't exceed maximum
WaitKey 'for screen
EXIT SUB
END IF
PRINT "Number of rows (1 -"; ScrRows%; ")"
INPUT ImageRows%
IF ImageRows% < 1 OR ImageRows% > ScrRows% THEN 'Check rows in same way
PRINT "Invalid number of rows"
WaitKey
EXIT SUB
END IF
MaxColumns% = ImageCols%
MaxRows% = ImageRows% 'Set global variables for drawing routines
END SUB
SUB SetSave 'Turn on saving and get filename for next save
SHARED Save% 'Global variable will be used by drawing routimes
CLS
PRINT "Save is "; 'Display current Save status
IF Save% THEN
PRINT "ON"
ELSE
PRINT "OFF"
END IF
PRINT
PRINT "Press any key to toggle Save Status"
PRINT "or Escape to leave: ";
PRINT
Status$ = INPUT$(1)
IF Status$ = CHR$(27) THEN 'Escape was pressed
EXIT SUB
ELSE
Save% = NOT Save%'Toggle Save status to opposite state and show the
IF Save% THEN 'result
PRINT "Save is ON"
ELSE
PRINT "Save is OFF"
END IF
WaitKey
END IF
END SUB
SUB SetScreen
SHARED Screens() AS ScreenType, MaxScreens%, Mode%
'Set screen mode
CLS
FOR S = 1 TO MaxScreens% 'List menu of available screens using the
PRINT Screens(S).Number; 'Screens array
PRINT Screens(S).Description
NEXT S
PRINT "Type the number of the screen you want"
PRINT "or Escape to exit"
Scr$ = INPUT$(1)
IF Scr$ = CHR$(27) THEN EXIT SUB
Scr% = VAL(Scr$)
Found = False 'Did user specify a valid screen?
FOR S = 1 TO MaxScreens%
IF Screens(S).Number = Scr% THEN
Found = True
EXIT FOR
END IF
NEXT S
IF Found THEN
Mode% = Scr%
SELECT CASE Mode% 'Choose proper initialization routine for this
CASE IS = 1 'screen
SetupCGA
CASE IS = 2
SetupMDA
CASE IS = 9
SetupEGA
CASE ELSE
PRINT "No code to set mode"; Mode%;
PRINT "in subprogram SetScreen."
END SELECT
PRINT "Screen set to"; Mode%
WaitKey
EXIT SUB
ELSE 'Specified screen was not found
PRINT "Sorry! Screen number"; Scr%;
PRINT "is not supported."
WaitKey
EXIT SUB
END IF
END SUB
SUB SetupCGA
SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%
Limit% = 1500 'How far to test formula
ColorDivisor% = 4 'Scale colors to CGA palette
MaxColumns% = 320 'Maximum values; SetImage routine can lower these
MaxRows% = 200 'values
SCREEN 1 'CGA (320 x 200, 4 colors)
END SUB
SUB SetupEGA
SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%
Limit% = 200 'Cutoff point
ColorDivisor% = 1 'Don't need to scale colors
MaxColumns% = 640 'Maximum values; SetImage routine can lower these
MaxRows% = 350 'values
SCREEN 9 'Hi-res EGA (640 x 350, 16 colors)
END SUB
SUB SetupMDA
SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%
Limit% = 3000
ColorDivisor% = 8
MaxColumns% = 640
MaxRows% = 200
SCREEN 2
END SUB
SUB ShowCGA (FileName$)
SCREEN 1 'CGA 320 x 200, 4 color mode
CLS
DEF SEG = &HB800 'Set to start of CGA memory
BLOAD FileName$ 'Load file directly into screen memory to show image;
AnimateCGA 'then add special effects
DEF SEG 'Restore default segment
END SUB
SUB ShowEGA (FileName$)
'Strip off the .EGA extension, since real files have four-color plane
'extensions
DotPos% = INSTR(FileName$, ".")
Name$ = LEFT$(FileName$, DotPos% - 1)
SCREEN 9 'EGA 640 x 350 16 color mode
CLS
DEF SEG = &HA000 'Set to start of EGA memory
'Manipulate EGA registers to load four planes from files
OUT &H3C4, 2
OUT &H3C5, 1
BLOAD Name$ + ".BLU", 0
OUT &H3C4, 2
OUT &H3C5, 2
BLOAD Name$ + ".GRN", 0
OUT &H3C4, 2
OUT &H3C5, 4
BLOAD Name$ + ".RED", 0
OUT &H3C4, 2
OUT &H3C5, 8
BLOAD Name$ + ".INT", 0
OUT &H3C4, 2
OUT &H3C5, 15
AnimateEGA 'Now add EGA special effects
DEF SEG 'Restore default segment
END SUB
SUB ShowFile
SHARED MaxScreens%, Screens() AS ScreenType, Mode%
'Show a fractal image from disk
'Calls specific routines for each screen type
TextScreen 'Restore text screen
PRINT "Enter name of file to show, including extension"
INPUT FileName$
Ext$ = UCASE$(RIGHT$(FileName$, 3))
Found = False
FOR S = 1 TO MaxScreens% 'Is this a valid extension?
IF Screens(S).Extension = Ext$ THEN
Found = True 'Extension is supported
END IF
NEXT S
IF Found = False THEN 'Extension is invalid
PRINT "Extension "; Ext$; " not supported"
EXIT SUB
ELSE
SELECT CASE Ext$ 'Call appropriate loading routine
CASE IS = "CGA", IS = "MDA" 'Fill in other CASEs as needed
ShowCGA (FileName$)
CASE IS = "EGA"
ShowEGA (FileName$)
CASE ELSE
PRINT "Invalid extension "; Ext$
END SELECT
END IF
END SUB
SUB ShowMenu
CONST MaxChoices% = 8 'Change if you add more menu items
DIM Choices$(10)
Choices$(1) = "1) Set Screen Type"
Choices$(2) = "2) Set Image Size"
Choices$(3) = "3) Set Save Status"
Choices$(4) = "4) Generate Fractal Image"
Choices$(5) = "5) Show Fractal from Disk"
Choices$(6) = "6) Statistics on Last Image Generated"
Choices$(7) = "7) Set Fractal Type"
Choices$(8) = "8) Exit Fractal Explorer"
WHILE True
TextScreen 'Start each time with normal 80 column text screen
PRINT "QBasic Fractal Explorer"
PRINT
FOR Choice = 1 TO MaxChoices%
PRINT Choices$(Choice)
NEXT Choice
ValidChoice% = False
WHILE NOT ValidChoice% 'Loop until valid choice entered
PRINT "Press number between 1 and"; MaxChoices%
PRINT "or press"; MaxChoices%; "to end program"
Choice$ = INPUT$(1)
Choice% = VAL(Choice$)
IF Choice% = MaxChoices% THEN END
IF Choice% < 1 OR Choice% > MaxChoices% THEN
BEEP
ELSE ValidChoice% = True
END IF
WEND
SELECT CASE Choice% 'Add more CASEs if you add features to the menu
CASE IS = 1
SetScreen
CASE IS = 2
SetImage
CASE IS = 3
SetSave
CASE IS = 4
DoFractal
CASE IS = 5
ShowFile
CASE IS = 6
ShowStats
CASE IS = 7
SetFractal
CASE ELSE 'Doesn't hurt to prepare for the unexpected!
PRINT "Error in menu setup"
PRINT "Choice was: "; Choice%
EXIT SUB
END SELECT
WEND
END SUB
SUB ShowStats
SHARED Time 'Value calculated in DoFractal routine
CLS
IF Time = 0 THEN
PRINT "No previous image generated this session."
WaitKey
EXIT SUB
END IF
PRINT "Last image took"; Time; "seconds."
WaitKey
END SUB
SUB TextScreen
SCREEN 0 'Set normal text screen
WIDTH 80, 25 'Set width to 80 columns and clear the screen
CLS
END SUB
SUB WaitKey
PRINT "Press any key to continue"
WHILE INKEY$ = "" 'Loop until key pressed
WEND
END SUB